home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Plus 2000 #5
/
Amiga Plus CD - 2000 - No. 5.iso
/
Tools
/
Dev
/
fpc
/
utils
/
dumpppu.pp
next >
Wrap
Text File
|
2000-01-01
|
28KB
|
802 lines
{****************************************************************************
$Id: dumpppu.pp,v 1.7 1998/08/12 12:17:07 carl Exp $
Dumps the contents of a FPC unit file (PPU File)
Copyright (c) 1995,97 by Florian Klaempfl and Michael Van Canneyt
Members of the FPC Development Team
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************}
{
possible compiler switches (* marks a currently required switch):
-----------------------------------------------------------------
BIG_ENDIAN Target machine on which this machine will run is
a BIG endian machine (such as the m68k)
}
{$ifdef TP}
{$N+,E+,G+}
{$endif}
program dumpppu;
var
f : file;
version : longint;
Filename : string;
nrfile : longint;
flags : byte;
const
ibloadunit = 1;
iborddef = 2;
ibpointerdef = 3;
ibtypesym = 4;
ibarraydef = 5;
ibprocdef = 6;
ibprocsym = 7;
iblinkofile = 8;
ibstringdef = 9;
ibvarsym = 10;
ibconstsym = 11;
ibinitunit = 12;
ibaufzaehlsym = 13;
ibtypedconstsym = 14;
ibrecorddef = 15;
ibfiledef = 16;
ibformaldef = 17;
ibobjectdef = 18;
ibenumdef = 19;
ibsetdef = 20;
ibprocvardef = 21;
ibsourcefile = 22;
ibdbxcount = 23;
ibfloatdef = 24;
ibref = 25;
ibextsymref = 26;
ibextdefref = 27;
ibabsolutesym = 28;
ibclassrefdef = 29;
ibpropertysym = 30;
iblibraries = 31;
iblongstringdef = 32;
ibansistringdef = 33;
ibunitname = 34;
ibwidestringdef = 35;
ibstaticlibs = 36;
ibend = 255;
{ unit flags }
uf_init = 1;
uf_uses_dbx = 2;
uf_uses_browser = 4;
uf_in_library = 8;
uf_shared_library = 16;
uf_big_endian = 32;
Type
absolutetyp = (tovar,toasm,toaddr);
tbasetype = (uauto,uvoid,uchar,
u8bit,u16bit,u32bit,
s8bit,s16bit,s32bit,
bool8bit,bool16bit,bool32bit);
{ don't change the order of these - used to determine processor }
{ taken from FPC v0.99.5 systems.pas }
ttarget = (target_GO32V1,target_OS2,target_LINUX,
target_WIN32,target_GO32V2,
target_Amiga,target_Atari,target_Mac68k);
var abstyp : absolutetyp;
utarget : ttarget;
function upper(const s : string) : string;
var
i : longint;
begin
for i:=1 to length(s) do
if s[i] in ['a'..'z'] then
upper[i]:=char(byte(s[i])-32)
else
upper[i]:=s[i];
upper[0]:=s[0];
end;
function readlong : longint;
var
l : longint;
w1, w2: word;
begin
blockread(f,l,4);
{$ifdef BIG_ENDIAN}
w1:=l and $ffff;
w2:=l shr 16;
l:=swap(w2)+(longint(swap(w1)) shl 16);
{$endif}
readlong:=l;
end;
function readword : word;
var
w : word;
begin
blockread(f,w,2);
{$IFDEF BIG_ENDIAN}
w:=swap(w);
{$ENDIF}
readword:=w;
end;
function readdouble : double;
var
d : double;
begin
blockread(f,d,8);
readdouble:=d;
end;
function readbyte : byte;
var
b : byte;
begin
blockread(f,b,1);
readbyte:=b;
end;
function readstring : string;
var
s : string;
begin
s[0]:=chr(readbyte);
blockread(f,s[1],ord(s[0]));
readstring:=s;
end;
var
space : string;
read_member : boolean;
procedure readandwriteref;
var
w : word;
begin
w:=readword;
if w=$ffff then
begin
w:=readword;
if w=$ffff then
writeln('nil')
else writeln('Local Definition Nr. ',w)
end
else writeln('Unit ',w,' Nr. ',readword)
end;
{ reads the flags of a definition }
procedure readflags;
begin
if version<13 then
readword;
end;
var
b : byte;
unitnumber : word;
type
tsettyp = (normset);
procedure readin;
var
oldread_member : boolean;
counter : word;
sourcename : string;
procedure read_abstract_proc_def;
var
params : word;
options : longint;
begin
write(space,' Return type : ');
readandwriteref;
if Version<13 then
options:=readword
else
options:=readlong;
if options<>0 then
begin
write(space,' Options : ');
if (options and 1)<>0 then
write('Exception handler ');
if (options and 2)<>0 then
write('Virtual Method ');
if (options and 4)<>0 then
write('Stack is not cleared, ');
if (options and 8)<>0 then
write('Constructor ');
if (options and $10)<>0 then
write('Destructor ');
if (options and $20)<>0 then
write('Internal Procedure ');
if (options and $40)<>0 then
write('Exported Procedure ');
if (options and $80)<>0 then
write('I/O-Checking');
if (options and $100)<>0 then
write('Abstract method');
if (options and $200)<>0 then
write('Interrupt Handler');
if (options and $400)<>0 then
write('Inline Procedure');
if (options and $800)<>0 then
write('Assembler Procedure');
if (options and $1000)<>0 then
write('Overloaded Operator');
if (options and $2000)<>0 then
write('External Procedure');
if (options and $4000)<>0 then
write('Expects parameters from left to right');
if (options and $8000)<>0 then
write('Main Program');
if (options and $10000)<>0 then
write('Static Method');
if (options and $20000)<>0 then
write('Method with Override Direktive');
if (options and $40000)<>0 then
write('Class Method');
if (options and $80000)<>0 then
write('Unit Initialisation');
if (options and $100000)<>0 then
write('Method Pointer (must be a procedure variable)');
writeln
end;
params:=readword;
writeln(space,' Nr of parameters: ',params);
if params>0 then
writeln(space,' Parameter defs : ');
while params>0 do
begin
write(space,' Type: ',readbyte,' ');
readandwriteref;
dec(params);
end;
end;
var
params : word;
IgnoreEnd : Longint;
begin
counter:=0;
IgnoreEnd:=0;
repeat
b:=readbyte;
if not (b in [ibend,ibloadunit,ibinitunit,iblinkofile,ibsourcefile,
iblibraries,ibunitname,ibstaticlibs]) then
begin
write(space,'Definition Nr. ',counter,' : ');
inc(counter);
end;
case b of
ibloadunit : begin
writeln('Uses unit (interface): ',readstring,' (',unitnumber,
') (Checksum: ',readlong,')');
inc(unitnumber);
{ version 12 writes a ibend after this.}
if version>=12 then inc(ignoreend);
end;
ibunitname : Writeln ('Unit name : ',readstring);
ibsourcefile : begin
{ Only version 12 and higher do this }
SourceName:=ReadString;
writeln ('Unit source file : ', SourceName);
{ stupid situation :
}
if Upper(SourceNAme)='SYSTEM.INC' then
{Systemunit:=true;}
Inc(IgnoreEnd);
if IgnoreEnd<1 then Inc(IgnoreEnd);
end;
iblibraries : Writeln ('Link with library : ', readstring);
ibstaticlibs : Writeln ('Link static with library : ',readstring);
ibpointerdef : begin
readflags;
write(space,'Pointerdefinition to : ');
readandwriteref;
end;
iborddef : begin
readflags;
write(space,'Base type ');
case tbasetype(readbyte) of
uauto : writeln('uauto');
uvoid : writeln('uvoid');
uchar : writeln('uchar');
u8bit : writeln('u8bit');
u16bit : writeln('u16bit');
u32bit : writeln('s32bit');
s8bit : writeln('s8bit');
s16bit : writeln('s16bit');
s32bit : writeln('s32bit');
bool8bit : writeln('bool8bit');
bool16bit : writeln('bool16bit');
bool32bit : writeln('bool32bit');
end;
writeln(space,' Range: ',readlong,' to ',readlong);
end;
ibfloatdef : begin
readflags;
writeln (space,'Float definition');
writeln (space, ' Float type : ',readbyte);
end;
ibarraydef : begin
readflags;
writeln(space,'Array definition');
write(space,' Element type: ');
readandwriteref;
write(space,' Range Type: ');
readandwriteref;
writeln(space,' Range: ',readlong,' to ',readlong);
end;
ibprocdef : begin
readflags;
writeln(space,'Procedure definition : ');
if version<8 then
begin
writeln(space,' Used Register: ',readbyte);
write(space, ' Return type : ');
readandwriteref;
write(space,' Options : ',readword);
writeln(space,' Mangled Name : ',readstring);
writeln(space,' Number : ',readlong);
write(space,' Next : ');
readandwriteref;
params:=readword;
writeln(space,' Nr. of Parameters: ',params);
writeln(space,' Parameter definitions: ');
while params>0 do
begin
write(space,' Type: ',readbyte,' ');
readandwriteref;
dec(params);
end;
end
else
begin
read_abstract_proc_def;
{ m68k targets use a word to save registers }
if utarget in [target_AMIGA..target_MAC68k] then
writeln(space,' Used Register : ',readword)
else
writeln(space,' Used Register : ',readbyte);
writeln(space,' Mangled name : ',readstring);
writeln(space,' Number : ',readlong);
write (space,' Next : ');
readandwriteref;
if version>11 then readlong;
end;
end;
ibprocvardef : begin
readflags;
writeln(space,'Procedural type :');
read_abstract_proc_def;
end;
ibstringdef:
begin
readflags;
writeln(space,'String definition with length: ',readbyte);
end;
ibwidestringdef:
begin
readflags;
writeln (space,'WideString definition with length: ',readlong);
end;
ibansistringdef:
begin
readflags;
writeln (space,'AnsiString definition with length: ',readlong);
end;
iblongstringdef:
begin
readflags;
writeln (space,'Longstring definition with length: ',readlong);
end;
ibrecorddef : begin
readflags;
writeln(space,'Record definition with size ',readlong);
oldread_member:=read_member;
read_member:=true;
space:=space+' ';
readin;
dec(byte(space[0]),4);
read_member:=oldread_member;
end;
ibobjectdef : begin
readflags;
writeln(space,'Class definition with size ',readlong);
writeln(space,' Name of Class : ',readstring);
write(space, ' Ancestor Class : ');
readandwriteref;
if version>12 then
writeln (space, ' Options : ',readlong)
else
writeln (space, ' Options : ',readword);
oldread_member:=read_member;
read_member:=true;
space:=space+' ';
readin;
dec(byte(space[0]),4);
read_member:=oldread_member;
end;
ibfiledef : begin
readflags;
case readbyte of
0 : writeln(space,'Text file definition');
1 : begin
write(space,'Typed file definition of Type : ');
readandwriteref;
end;
2 : writeln(space,'Untyped file definition');
end;
end;
ibformaldef:
begin
readflags;
writeln(space,'Generic Definition (void-typ)');
end;
ibenumdef:
begin
readflags;
writeln(space,'Enumeration type definition');
writeln(space,'Largest element: ',readlong);
end;
ibclassrefdef:
begin
readflags;
write(space,'Class reference definition to: ');
readandwriteref;
end;
ibinitunit : writeln('Needs Initialising: ',readstring);
iblinkofile : writeln('Link with: ',readstring);
ibsetdef : begin
readflags;
writeln(space,'Set definition');
write(space,' Element type: ');
readandwriteref;
b:=readbyte;
case tsettyp(b) of
normset : writeln(space,' Set with 256 Elements');
else
begin
writeln('Invalid unit format : Invalid set type.');
exit;
end;
end;
end;
ibref : begin
writeln ('Error : Don''t know how to handle IBREF yet.');
exit;
end;
ibextsymref : begin
writeln ('Error : Don''t know how to handle IBEXTSYMREF yet.');
exit;
end;
ibextdefref : begin
writeln ('Error : Don''t know how to handle IBEXTDEFREF yet.');
exit;
end;
ibend : begin
if (version<12) or (ignoreend<=0) then
break
else
dec(ignoreend);
end;
else
begin
writeln('Invalid unit format : Invalid definition type encountered : ',b);
exit;
end;
end;
until false;
repeat
b:=readbyte;
case b of
ibtypesym : begin
writeln(space,'Type symbol ',readstring);
write(space,' Definition: ');
readandwriteref;
end;
ibprocsym : begin
writeln(space,'Procedure symbol ',readstring);
write(space,' Definition: ');
readandwriteref;
end;
ibconstsym : begin
if version<10 then
begin
writeln(space,'Constant symbol ',readstring);
write(space,' Value: ');
case readbyte of
0 : writeln(readlong);
1 : writeln('"'+readstring+'"');
2 : writeln(''''+chr(readbyte)+'''');
3 : writeln(readdouble);
4 : if readbyte=0 then writeln('FALSE')
else writeln('TRUE');
end;
end
else if version<12 then
begin
writeln(space,'Constant symbol ',readstring);
write(space,' Definition: ');
b:=readbyte;
readandwriteref;
write(space,' Value: ');
case b of
0 : writeln(readlong);
1 : writeln('"'+readstring+'"');
2 : writeln(readdouble);
end;
end
else
begin
writeln(space,'Constant symbol ',readstring);
b:=readbyte;
if b<>0 then
write(space,' Value: ');
case b of
0 : begin
write (space,' Definition : ');
readandwriteref;
writeln (space,' Value : ',readlong)
end;
3 : if readlong<>0 then
writeln ('True')
else
writeln ('False');
4,5 : writeln(readlong);
1 : writeln('"'+readstring+'"');
2 : writeln(readdouble);
end;
end;
end;
ibvarsym : begin
write(space,'Variable symbol ',readstring);
write(' (Type: ',readbyte);
if read_member then
write(', Address: ',readlong);
writeln (')');
write(space,' Definition: ');
readandwriteref;
end;
ibaufzaehlsym : begin
writeln(space,'Enumeration symbol ',readstring);
write(space,' Definition: ');
readandwriteref;
writeln(space,' Value: ',readlong);
end;
ibtypedconstsym : begin
writeln(space,'Typed constant ',readstring);
write(space,' Definition');
readandwriteref;
writeln(space,' Label: ',readstring);
end;
ibabsolutesym : begin
write(space,'Absolute variable symbol ',readstring);
write(' (Type: ',readbyte);
if read_member then
write(', Address: ',readlong);
writeln (')');
write(space,' Definition: ');
readandwriteref;
abstyp:=absolutetyp(readbyte);
Write (space,' Relocated to ');
case abstyp of
tovar : Writeln ('Name : ',readstring);
toasm : Writeln ('Assembler name : ',readstring);
toaddr : Writeln ('Address : ',readlong);
else
Writeln ('Invalid unit format : Invalid absolute type encountered :',byte(abstyp));
end;
end;
ibend : break;
else
begin
writeln('Invalid Unit format : Invalid symbol type encountered :', b);
exit;
end;
end;
until false;
if (version>11) and not read_member then
begin
{ Check use of dbx }
if (flags and uf_uses_dbx)<>0 then
begin
Writeln ('DBXcount : ',readbyte,',',readlong);
if readbyte<>ibend then Writeln ('Illegal unit file.')
end;
{ Read implementation units. }
repeat
b:=readbyte;
case b of
ibend : ;
ibloadunit : begin
Write ('Uses unit (implementation) : ',readstring);
Writeln (' Checksum : ',readlong);
end;
else
begin
writeln ('Invalid unit file : No used units part.');
exit;
end;
end;
until b=ibend;
end;
end;
var
hs : string;
w : word;
procedure dofile (const s : string);
begin
filename:=s;
assign(f,filename);
{$i-}
reset(f,1);
{$i+}
if IOResult<>0 then
begin
writeln ('IO-Error when opening :',filename,', Skipping.');
exit
end
else
Writeln ('Reading file : ',filename);
if (readbyte<>ord('P')) or
(readbyte<>ord('P')) or
(readbyte<>ord('U')) then
begin
writeln(Filename,' : Not a valid PPU file. Skipping');
end
else
begin
hs:=chr(readbyte)+chr(readbyte)+chr(readbyte);
val(hs,version,w);
writeln('PPU version : ',version);
writeln('Compiler version : ',readbyte,'.',readbyte);
write ('Target operating system : ');
utarget:=ttarget(readbyte);
case utarget of
target_GO32V1 : writeln('DOS');
target_OS2 : writeln('OS/2');
target_LINUX : writeln('Linux');
target_WIN32 : writeln('Win32');
target_AMIGA : writeln('Amiga');
target_ATARI : writeln('Atari');
target_Mac68k: writeln('Mac-68k');
end;
flags:=readbyte;
write ('Unit flags : ',flags,', ');
if (flags and uf_init)<>0 then
write('init ');
if (flags and uf_uses_dbx)<>0 then
write('uses_dbx ');
if (flags and uf_uses_browser)<>0 then
write('uses_browser ');
if (flags and uf_in_library)<>0 then
write('in_library ');
if (flags and uf_shared_library)<>0 then
write('shared_library ');
if (flags and uf_big_endian)<>0 then
write('big_endian');
if (flags=0) then
write('(none)');
writeln;
writeln ('Checksum : ',readlong);
readword;
if version>=9 then
writeln ('Object code start : ',readlong);
unitnumber:=1;
space:='';
read_member:=false;
readin;
end;
close(f);
writeln;
end;
begin
writeln('PPU-analyser Version 0.99');
writeln('Copyright (c) 1995-98 by Florian Klaempfl and Michael Van Canneyt');
writeln;
filemode:=0;
if paramcount<1 then
begin
writeln('dumpppu <filename1> <filename2>...');
halt(1);
end;
for nrfile :=1 to paramcount do
dofile (paramstr(nrfile));
end.
{
$Log: dumpppu.pp,v $
Revision 1.7 1998/08/12 12:17:07 carl
* Make it work with FPC 0.99.5
+ m68k targets support
+ BIG_ENDIAN machine support
Revision 1.5 1998/06/12 14:46:07 peter
* update tbasetype
Revision 1.4 1998/05/07 08:48:12 michael
+ Some cosmetic changes for smart linking.
Revision 1.3 1998/05/06 11:05:32 michael
+ Updated to ppu version 14. Added strings and unitname handlers
Revision 1.2 1998/04/29 22:41:17 florian
* better decoding of procedure options
+ support of PPU format 14
}
